home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / require.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  9.3 KB  |  275 lines
  1. ;;;; Implementation of VICINITY and MODULES for Scheme
  2. ;Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define *SLIB-VERSION* "2c8")
  21.  
  22. ;;; Standardize msdos -> ms-dos.
  23. (define software-type
  24.   (cond ((eq? 'msdos (software-type))
  25.      (lambda () 'ms-dos))
  26.     (else software-type)))
  27.  
  28. (define (user-vicinity)
  29.   (case (software-type)
  30.     ((VMS)    "[.]")
  31.     (else    "")))
  32.  
  33. (define *load-pathname* #f)
  34. (define vicinity:suffix?
  35.   (let ((suffi
  36.      (case (software-type)
  37.        ((AMIGA)                '(#\: #\/))
  38.        ((MACOS THINKC)            '(#\:))
  39.        ((MS-DOS WINDOWS ATARIST OS/2)    '(#\\ #\/))
  40.        ((NOSVE)                '(#\: #\.))
  41.        ((UNIX COHERENT)            '(#\/))
  42.        ((VMS)                '(#\: #\])))))
  43.     (lambda (chr) (memv chr suffi))))
  44. (define (program-vicinity)
  45.   (if *load-pathname*
  46.       (let loop ((i (- (string-length *load-pathname*) 1)))
  47.     (cond ((negative? i) "")
  48.           ((vicinity:suffix? (string-ref *load-pathname* i))
  49.            (substring *load-pathname* 0 (+ i 1)))
  50.           (else (loop (- i 1)))))
  51.       (slib:error "Not loading but called" 'program-vicinity)))
  52.  
  53. (define sub-vicinity
  54.   (case (software-type)
  55.     ((VMS) (lambda
  56.            (vic name)
  57.          (let ((l (string-length vic)))
  58.            (if (or (zero? (string-length vic))
  59.                (not (char=? #\] (string-ref vic (- l 1)))))
  60.            (string-append vic "[" name "]")
  61.            (string-append (substring vic 0 (- l 1))
  62.                   "." name "]")))))
  63.     (else (let ((*vicinity-suffix*
  64.          (case (software-type)
  65.            ((NOSVE) ".")
  66.            ((MACOS THINKC) ":")
  67.            ((MS-DOS WINDOWS ATARIST OS/2) "\\")
  68.            ((UNIX COHERENT AMIGA) "/"))))
  69.         (lambda (vic name)
  70.           (string-append vic name *vicinity-suffix*))))))
  71.  
  72. (define (make-vicinity <pathname>) <pathname>)
  73.  
  74. (define (slib:pathnameize-load *old-load*)
  75.   (lambda (<pathname> . extra)
  76.     (let ((old-load-pathname *load-pathname*))
  77.       (set! *load-pathname* <pathname>)
  78.       (apply *old-load* (cons <pathname> extra))
  79.       (require:provide <pathname>)
  80.       (set! *load-pathname* old-load-pathname))))
  81.  
  82. (set! slib:load-source
  83.       (slib:pathnameize-load slib:load-source))
  84. (set! slib:load
  85.       (slib:pathnameize-load slib:load))
  86.  
  87. ;;;; MODULES
  88.  
  89. (define *catalog* #f)
  90. (define *modules* '())
  91.  
  92. (define (require:version path)
  93.   (let ((expr (and (file-exists? path)
  94.            (call-with-input-file path (lambda (port) (read port))))))
  95.     (and (list? expr) (= 3 (length expr))
  96.      (eq? (car expr) 'define) (eq? (cadr expr) '*SLIB-VERSION*)
  97.      (string? (caddr expr)) (caddr expr))))
  98.  
  99. (define (catalog/require-version-match? slibcat)
  100.   (let* ((apair (assq '*SLIB-VERSION* slibcat))
  101.      (req (in-vicinity (library-vicinity)
  102.                (string-append "require" (scheme-file-suffix))))
  103.      (reqvers (require:version req)))
  104.     (cond ((not (file-exists? req))
  105.        (slib:warn "can't find " req) #f)
  106.       ((not apair) #f)
  107.       ((not (equal? reqvers (cdr apair))) #f)
  108.       ((not (equal? reqvers *SLIB-VERSION*))
  109.        (slib:warn "The loaded " req " is stale.")
  110.        #t)
  111.       (else #t))))
  112.  
  113. (define (catalog:try-read vicinity name)
  114.   (or (and vicinity name
  115.        (let ((path (in-vicinity vicinity name)))
  116.          (and (file-exists? path)
  117.           (call-with-input-file path
  118.             (lambda (port)
  119.               (do ((expr (read port) (read port))
  120.                (lst '() (cons expr lst)))
  121.               ((eof-object? expr)
  122.                (apply append lst))))))))
  123.       '()))
  124.  
  125. (define (catalog:get feature)
  126.   (if (not *catalog*)
  127.       (let ((slibcat (catalog:try-read (implementation-vicinity) "slibcat")))
  128.     (cond ((not (catalog/require-version-match? slibcat))
  129.            (slib:load (in-vicinity (library-vicinity) "mklibcat"))
  130.            (set! slibcat
  131.              (catalog:try-read (implementation-vicinity) "slibcat"))))
  132.     (cond (slibcat
  133.            (set! *catalog* ((slib:eval
  134.                  (cadr (or (assq 'catalog:filter slibcat)
  135.                        '(#f identity))))
  136.                 slibcat))))
  137.     (set! *catalog*
  138.           (append (catalog:try-read (home-vicinity) "homecat") *catalog*))
  139.     (set! *catalog*
  140.           (append (catalog:try-read (user-vicinity) "usercat") *catalog*))))
  141.   (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f)))))
  142.  
  143. (define (require:provided? feature)
  144.   (if (symbol? feature)
  145.       (if (memq feature *features*) #t
  146.       (and *catalog*
  147.            (let ((path (catalog:get feature)))
  148.          (cond ((symbol? path) (require:provided? path))
  149.                ((member (if (pair? path) (cdr path) path) *modules*)
  150.             #t)
  151.                (else #f)))))
  152.       (and (member feature *modules*) #t)))
  153.  
  154. (define (require:feature->path feature)
  155.   (and (symbol? feature)
  156.        (let ((path (catalog:get feature)))
  157.      (if (symbol? path) (require:feature->path path) path))))
  158.  
  159. (define (require:require feature)
  160.   (or (require:provided? feature)
  161.       (let ((path (catalog:get feature)))
  162.     (cond ((and (not path) (string? feature) (file-exists? feature))
  163.            (set! path feature)))
  164.     (cond ((not feature) (set! *catalog* #f))
  165.           ((not path)
  166.            (slib:error ";required feature not supported: " feature))
  167.           ((symbol? path) (require:require path) (require:provide feature))
  168.           ((not (pair? path))    ;simple name
  169.            (slib:load path)
  170.            (and (not (eq? 'new-catalog feature)) (require:provide feature)))
  171.           (else            ;special loads
  172.            (require:require (car path))
  173.            (apply (case (car path)
  174.             ((macro) macro:load)
  175.             ((syntactic-closures) synclo:load)
  176.             ((syntax-case) syncase:load)
  177.             ((macros-that-work) macwork:load)
  178.             ((macro-by-example) defmacro:load)
  179.             ((defmacro) defmacro:load)
  180.             ((source) slib:load-source)
  181.             ((compiled) slib:load-compiled)
  182.             (else (slib:error "unknown package loader" path)))
  183.               (if (list? path) (cdr path) (list (cdr path))))
  184.            (require:provide feature))))))
  185.  
  186. (define (require:provide feature)
  187.   (if (symbol? feature)
  188.       (if (not (memq feature *features*))
  189.       (set! *features* (cons feature *features*)))
  190.       (if (not (member feature *modules*))
  191.       (set! *modules* (cons feature *modules*)))))
  192.  
  193. (require:provide 'vicinity)
  194.  
  195. (define provide require:provide)
  196. (define provided? require:provided?)
  197. (define require require:require)
  198.  
  199. (if (and (string->number "0.0") (inexact? (string->number "0.0")))
  200.     (require:provide 'inexact))
  201. (if (rational? (string->number "1/19")) (require:provide 'rational))
  202. (if (real? (string->number "0.0")) (require:provide 'real))
  203. (if (complex? (string->number "1+i")) (require:provide 'complex))
  204. (let ((n (string->number "9999999999999999999999999999999")))
  205.   (if (and n (exact? n)) (require:provide 'bignum)))
  206.  
  207. (define report:print
  208.   (lambda args
  209.     (for-each (lambda (x) (write x) (display #\ )) args)
  210.     (newline)))
  211.  
  212. (define slib:report
  213.   (let ((slib:report (lambda () (slib:report-version) (slib:report-locations))))
  214.     (lambda args
  215.       (cond ((null? args) (slib:report))
  216.         ((not (string? (car args)))
  217.          (slib:report-version) (slib:report-locations #t))
  218.         ((require:provided? 'transcript)
  219.          (transcript-on (car args))
  220.          (slib:report)
  221.          (transcript-off))
  222.         ((require:provided? 'with-file)
  223.          (with-output-to-file (car args) slib:report))
  224.         (else (slib:report))))))
  225.  
  226. (define slib:report-version
  227.   (lambda ()
  228.     (report:print
  229.      'SLIB *SLIB-VERSION* 'on (scheme-implementation-type)
  230.      (scheme-implementation-version) 'on (software-type))))
  231.  
  232. (define slib:report-locations
  233.   (let ((features *features*))
  234.     (lambda args
  235.       (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
  236.       (report:print '(LIBRARY-VICINITY) 'is (library-vicinity))
  237.       (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix))
  238.       (cond (*load-pathname*
  239.          (report:print '*LOAD-PATHNAME* 'is *load-pathname*)))
  240.       (cond ((not (null? *modules*))
  241.          (report:print 'Loaded '*MODULES* 'are: *modules*)))
  242.       (let* ((i (+ -1 5)))
  243.     (cond ((eq? (car features) (car *features*)))
  244.           (else (report:print 'loaded '*FEATURES* ':) (display slib:tab)))
  245.     (for-each
  246.      (lambda (x)
  247.        (cond ((eq? (car features) x)
  248.           (if (not (eq? (car features) (car *features*))) (newline))
  249.           (report:print 'Implementation '*FEATURES* ':)
  250.           (display slib:tab) (set! i (+ -1 5)))
  251.          ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5)))
  252.          ((not (= (+ -1 5) i)) (display #\ )))
  253.        (write x) (set! i (+ -1 i)))
  254.      *features*))
  255.       (newline)
  256.       (report:print 'Implementation '*CATALOG* ':)
  257.       (catalog:get #f)
  258.       (cond ((pair? args)
  259.          (for-each (lambda (x) (display slib:tab) (report:print x))
  260.                *catalog*))
  261.         (else (display slib:tab) (report:print (car *catalog*))
  262.           (display slib:tab) (report:print '...)))
  263.       (newline))))
  264.  
  265. (let ((sit (scheme-implementation-version)))
  266.   (cond ((zero? (string-length sit)))
  267.     ((or (not (string? sit)) (char=? #\? (string-ref sit 0)))
  268.      (newline)
  269.      (slib:report-version)
  270.      (report:print 'edit (scheme-implementation-type) ".init"
  271.                'to 'set '(scheme-implementation-version) 'string)
  272.      (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
  273.      (report:print 'type '(slib:report) 'for 'configuration)
  274.      (newline))))
  275.